library(corrplot)
library(corrgram)
library(skimr)
library(knitr)
library(ggplot2)
library(dplyr)
library(formattable)
library(randomForest)
library(caret)
library(readr)
library(gmodels)
library(rpart)
library(rpart.plot)
library(polycor)
library(cluster)
library(fpc)Esta análise aplica-se a um dataset de variantes do vinho portugues “Vinho Verde”, possuindo diversos indicadores de suas caracteristicas, como acidez, teor alcoolico, quantidade de açucar, entre outros…
## id_vinho fixedacidity volatileacidity citricacid
## Min. : 1 Min. : 3.800 Min. :0.0800 Min. :0.0000
## 1st Qu.:1625 1st Qu.: 6.400 1st Qu.:0.2300 1st Qu.:0.2500
## Median :3249 Median : 7.000 Median :0.2900 Median :0.3100
## Mean :3249 Mean : 7.215 Mean :0.3397 Mean :0.3186
## 3rd Qu.:4873 3rd Qu.: 7.700 3rd Qu.:0.4000 3rd Qu.:0.3900
## Max. :6497 Max. :15.900 Max. :1.5800 Max. :1.6600
## residualsugar chlorides freesulfurdioxide totalsulfurdioxide
## Min. : 0.60 Min. :0.00900 Min. : 1.00 Min. : 6.0
## 1st Qu.: 1.80 1st Qu.:0.03800 1st Qu.: 17.00 1st Qu.: 77.0
## Median : 3.00 Median :0.04700 Median : 29.00 Median :118.0
## Mean : 5.44 Mean :0.05603 Mean : 30.53 Mean :115.7
## 3rd Qu.: 8.10 3rd Qu.:0.06500 3rd Qu.: 41.00 3rd Qu.:156.0
## Max. :45.80 Max. :0.61100 Max. :289.00 Max. :440.0
## density pH sulphates alcohol
## Min. :0.9871 Min. :2.720 Min. :0.2200 Min. : 0.9567
## 1st Qu.:0.9923 1st Qu.:3.110 1st Qu.:0.4300 1st Qu.: 9.5000
## Median :0.9949 Median :3.210 Median :0.5100 Median :10.3000
## Mean :0.9947 Mean :3.219 Mean :0.5313 Mean :10.4862
## 3rd Qu.:0.9970 3rd Qu.:3.320 3rd Qu.:0.6000 3rd Qu.:11.3000
## Max. :1.0140 Max. :4.010 Max. :2.0000 Max. :14.9000
## quality Vinho
## Min. :3.000 RED :1599
## 1st Qu.:5.000 WHITE:4898
## Median :6.000
## Mean :5.818
## 3rd Qu.:6.000
## Max. :9.000
## 'data.frame': 6497 obs. of 14 variables:
## $ id_vinho : int 1 2 3 4 5 6 7 8 9 10 ...
## $ fixedacidity : num 6.6 6.7 10.6 5.4 6.7 6.8 6.6 7.2 5.1 6.2 ...
## $ volatileacidity : num 0.24 0.34 0.31 0.18 0.3 0.5 0.61 0.66 0.26 0.22 ...
## $ citricacid : num 0.35 0.43 0.49 0.24 0.44 0.11 0 0.33 0.33 0.2 ...
## $ residualsugar : num 7.7 1.6 2.2 4.8 18.8 ...
## $ chlorides : num 0.031 0.041 0.063 0.041 0.057 0.075 0.069 0.068 0.027 0.035 ...
## $ freesulfurdioxide : num 36 29 18 30 65 16 4 34 46 58 ...
## $ totalsulfurdioxide: num 135 114 40 113 224 49 8 102 113 184 ...
## $ density : num 0.994 0.99 0.998 0.994 1 ...
## $ pH : num 3.19 3.23 3.14 3.42 3.11 3.36 3.33 3.27 3.35 3.11 ...
## $ sulphates : num 0.37 0.44 0.51 0.4 0.53 0.79 0.37 0.78 0.43 0.53 ...
## $ alcohol : num 10.5 12.6 9.8 9.4 9.1 9.5 10.4 12.8 11.4 9 ...
## $ quality : int 5 6 6 6 5 5 4 6 7 6 ...
## $ Vinho : Factor w/ 2 levels "RED","WHITE": 2 2 1 2 2 1 1 1 2 2 ...
Dataset com 13 variaveis, dentre elas a variável “quality” indica a qualidade medida de cada vinho.
É importante averiguarmos a existẽncia de dados incompletos na amostra de modo que possam influenciar a análise e o desenvolvimento dos modelos estatísticos:
Skim summary statistics
n obs: 6497
n variables: 14
Variable type: factor
| variable | missing | complete | n | n_unique | top_counts | ordered |
|---|---|---|---|---|---|---|
| Vinho | 0 | 6497 | 6497 | 2 | WHI: 4898, RED: 1599, NA: 0 | FALSE |
Variable type: integer
| variable | missing | complete | n | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|---|
| id_vinho | 0 | 6497 | 6497 | 3249 | 1875.67 | 1 | 1625 | 3249 | 4873 | 6497 | ▇▇▇▇▇▇▇▇ |
| quality | 0 | 6497 | 6497 | 5.82 | 0.87 | 3 | 5 | 6 | 6 | 9 | ▁▁▆▇▁▃▁▁ |
Variable type: numeric
| variable | missing | complete | n | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|---|
| alcohol | 0 | 6497 | 6497 | 10.49 | 1.22 | 0.96 | 9.5 | 10.3 | 11.3 | 14.9 | ▁▁▁▁▆▇▃▁ |
| chlorides | 0 | 6497 | 6497 | 0.056 | 0.035 | 0.009 | 0.038 | 0.047 | 0.065 | 0.61 | ▇▁▁▁▁▁▁▁ |
| citricacid | 0 | 6497 | 6497 | 0.32 | 0.15 | 0 | 0.25 | 0.31 | 0.39 | 1.66 | ▂▇▂▁▁▁▁▁ |
| density | 0 | 6497 | 6497 | 0.99 | 0.003 | 0.99 | 0.99 | 0.99 | 1 | 1.01 | ▂▇▇▅▁▁▁▁ |
| fixedacidity | 0 | 6497 | 6497 | 7.22 | 1.3 | 3.8 | 6.4 | 7 | 7.7 | 15.9 | ▁▇▇▂▁▁▁▁ |
| freesulfurdioxide | 0 | 6497 | 6497 | 30.53 | 17.75 | 1 | 17 | 29 | 41 | 289 | ▇▃▁▁▁▁▁▁ |
| pH | 0 | 6497 | 6497 | 3.22 | 0.16 | 2.72 | 3.11 | 3.21 | 3.32 | 4.01 | ▁▃▇▇▃▁▁▁ |
| residualsugar | 0 | 6497 | 6497 | 5.44 | 4.73 | 0.6 | 1.8 | 3 | 8.1 | 45.8 | ▇▂▂▁▁▁▁▁ |
| sulphates | 0 | 6497 | 6497 | 0.53 | 0.15 | 0.22 | 0.43 | 0.51 | 0.6 | 2 | ▅▇▂▁▁▁▁▁ |
| totalsulfurdioxide | 0 | 6497 | 6497 | 115.74 | 56.52 | 6 | 77 | 118 | 156 | 440 | ▅▆▇▃▁▁▁▁ |
| volatileacidity | 0 | 6497 | 6497 | 0.34 | 0.16 | 0.08 | 0.23 | 0.29 | 0.4 | 1.58 | ▇▇▂▁▁▁▁▁ |
Outliers são observações que apresentam grandes afastamentos das demais e/ou são inconsistentes com estas. Um bom método de verificar a existência de outliers é a análise gráfica, através de um histograma sobreposto pela distribuição normal e duas linhas que delimitem o limite mínimo e máximo de corte, também é usado o gráfico bloxpot.
hist.default <- function(x,
breaks = "Sturges",
freq = NULL,
include.lowest = TRUE,
normalcurve = TRUE,
right = TRUE,
density = NULL,
angle = 45,
col = NULL,
border = NULL,
main = paste("Histogram of", xname),
ylim = NULL,
xlab = xname,
ylab = NULL,
axes = TRUE,
plot = TRUE,
labels = FALSE,
warn.unused = TRUE,
...) {
xname <- paste(deparse(substitute(x), 500), collapse = "\n")
suppressWarnings(
h <- graphics::hist.default(
x = x,
breaks = breaks,
freq = freq,
include.lowest = include.lowest,
right = right,
density = density,
angle = angle,
col = col,
border = border,
main = main,
ylim = ylim,
xlab = xlab,
ylab = ylab,
axes = axes,
plot = plot,
labels = labels,
warn.unused = warn.unused,
...
)
)
if (normalcurve == TRUE & plot == TRUE) {
x <- x[!is.na(x)]
xfit <- seq(min(x), max(x), length = 40)
yfit <- dnorm(xfit, mean = mean(x), sd = sd(x))
if (isTRUE(freq) | (is.null(freq) & is.null(density))) {
yfit <- yfit * diff(h$mids[1:2]) * length(x)
}
lines(xfit, yfit, col = "black", lwd = 2)
}
if (plot == TRUE) {
invisible(h)
} else {
h
}
}
plotaGraficos <- function(fVinho, label){
par(mfrow = c(1,2))
hist(fVinho, main = paste("Histograma de ",label), xlab = label, ylab="Frequência")
abline(v = mean(fVinho) - 2 * sd(fVinho), col = "red")
abline(v = mean(fVinho) + 2 * sd(fVinho), col = "red")
boxplot(fVinho)
}
plotaGraficos(vinhos$fixedacidity, "fixedacidity")Pelo boxplot é possível visualizar que há grupos distintos de vinhos dadas as características físico-químicas e a qualidade entre eles, mas também é possível notar que nas variáveis “residualsugar”, “freesilfurdioxide” e “totalsulfurdioxide” existem observações com valores muito distantes dos agrupamentos no gráfico e consideramos estas possíveis outliers, sendo assim, serão removidos para que não interfiram no resultado da análise e dos algoritmos
vinhos <- vinhos%>%filter(residualsugar < 40)
vinhos <- vinhos%>%filter(freesulfurdioxide < 200)
vinhos <- vinhos%>%filter(totalsulfurdioxide < 400)
plotaGraficos(vinhos$residualsugar, "residualsugar")Gerando a correlação das variaveis, vai permitir o entendimento de quais carácteristicas estão mais relacionadas a nota de qualidade dadas aos vinho.
Vamos começar pela matriz de correlação.
Matriz de correlação mostra os valores de correlação de Pearson, que medem o grau de relação linear entre cada par de itens ou variáveis. Os valores de correlação podem cair entre -1 e +1.
matcor <- cor(vinhos%>%select(2:13))
panel.cor <- function(x, y, digits=2, prefix ="", cex.cor,
...) {
usr <- par("usr")
on.exit(par(usr))
par(usr = c(0, 1, 0, 1))
r <- cor(x, y , use = "pairwise.complete.obs")
txt <- format(c(r, 0.123456789), digits = digits) [1]
txt <- paste(prefix, txt, sep = "")
if (missing(cex.cor))
cex <- 0.8/strwidth(txt)
text(0.5, 0.5, txt, cex = cex * abs(r))
}
pairs(vinhos%>%select(2:13), lower.panel=panel.smooth, upper.panel=panel.cor)A Qualidade dos vinhos apresenta correlação com o teor alcoólico, densidade e acidez volátil, ainda que não seja um alto grau de correlação, porém, outras variáveis do dataset apresentam alta correlação entre si.
Tendo como alvo a qualidade dos vinhos, usaremos as características físico-químicas dos mesmos e usaremos duas técnicas diferentes para obtermos nossa variável de resposta.
A regressão linear consiste em uma função que relaciona as variáveis que contém características do objeto de estudo a uma varíavel depente do mesmo objeto de estudo, gerando assim uma relação entre o resultado observado às suas possíveis explicações.
Usaremos o método stepwise no desenvolvimento do modelo, selecionando assim as variáveis que melhor estimem a qualidade do vinho
vinhos_rl <- vinhos%>%select(2:13)
modelo_rl <- lm(vinhos$quality ~ vinhos_rl$fixedacidity + vinhos_rl$volatileacidity + vinhos_rl$citricacid + vinhos_rl$residualsugar + vinhos_rl$chlorides + vinhos_rl$freesulfurdioxide + vinhos_rl$totalsulfurdioxide + vinhos_rl$density + vinhos_rl$pH + vinhos_rl$sulphates + vinhos_rl$alcohol)
stepwise<-step(modelo_rl,direction="both")## Start: AIC=-3954.3
## vinhos$quality ~ vinhos_rl$fixedacidity + vinhos_rl$volatileacidity +
## vinhos_rl$citricacid + vinhos_rl$residualsugar + vinhos_rl$chlorides +
## vinhos_rl$freesulfurdioxide + vinhos_rl$totalsulfurdioxide +
## vinhos_rl$density + vinhos_rl$pH + vinhos_rl$sulphates +
## vinhos_rl$alcohol
##
## Df Sum of Sq RSS AIC
## - vinhos_rl$citricacid 1 0.963 3521.2 -3954.5
## - vinhos_rl$chlorides 1 0.977 3521.2 -3954.5
## <none> 3520.2 -3954.3
## - vinhos_rl$fixedacidity 1 25.207 3545.4 -3910.0
## - vinhos_rl$pH 1 25.430 3545.6 -3909.5
## - vinhos_rl$density 1 31.458 3551.6 -3898.5
## - vinhos_rl$freesulfurdioxide 1 43.014 3563.2 -3877.4
## - vinhos_rl$totalsulfurdioxide 1 54.672 3574.9 -3856.2
## - vinhos_rl$residualsugar 1 63.273 3583.5 -3840.6
## - vinhos_rl$sulphates 1 69.150 3589.3 -3830.0
## - vinhos_rl$alcohol 1 91.819 3612.0 -3789.1
## - vinhos_rl$volatileacidity 1 139.605 3659.8 -3703.7
##
## Step: AIC=-3954.52
## vinhos$quality ~ vinhos_rl$fixedacidity + vinhos_rl$volatileacidity +
## vinhos_rl$residualsugar + vinhos_rl$chlorides + vinhos_rl$freesulfurdioxide +
## vinhos_rl$totalsulfurdioxide + vinhos_rl$density + vinhos_rl$pH +
## vinhos_rl$sulphates + vinhos_rl$alcohol
##
## Df Sum of Sq RSS AIC
## <none> 3521.2 -3954.5
## + vinhos_rl$citricacid 1 0.963 3520.2 -3954.3
## - vinhos_rl$chlorides 1 1.340 3522.5 -3954.1
## - vinhos_rl$fixedacidity 1 24.317 3545.5 -3911.8
## - vinhos_rl$pH 1 26.135 3547.3 -3908.5
## - vinhos_rl$density 1 31.387 3552.5 -3898.9
## - vinhos_rl$freesulfurdioxide 1 43.318 3564.5 -3877.1
## - vinhos_rl$totalsulfurdioxide 1 58.696 3579.9 -3849.1
## - vinhos_rl$residualsugar 1 62.815 3584.0 -3841.7
## - vinhos_rl$sulphates 1 68.509 3589.7 -3831.4
## - vinhos_rl$alcohol 1 90.915 3612.1 -3791.0
## - vinhos_rl$volatileacidity 1 153.190 3674.3 -3679.9
##
## Call:
## lm(formula = vinhos$quality ~ vinhos_rl$fixedacidity + vinhos_rl$volatileacidity +
## vinhos_rl$residualsugar + vinhos_rl$chlorides + vinhos_rl$freesulfurdioxide +
## vinhos_rl$totalsulfurdioxide + vinhos_rl$density + vinhos_rl$pH +
## vinhos_rl$sulphates + vinhos_rl$alcohol)
##
## Residuals:
## Min 1Q Median 3Q Max
## -3.5625 -0.4657 -0.0423 0.4708 3.0081
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 9.185e+01 1.181e+01 7.779 8.44e-15 ***
## vinhos_rl$fixedacidity 1.008e-01 1.507e-02 6.692 2.39e-11 ***
## vinhos_rl$volatileacidity -1.194e+00 7.111e-02 -16.796 < 2e-16 ***
## vinhos_rl$residualsugar 5.449e-02 5.066e-03 10.755 < 2e-16 ***
## vinhos_rl$chlorides -5.181e-01 3.299e-01 -1.571 0.116
## vinhos_rl$freesulfurdioxide 6.859e-03 7.680e-04 8.931 < 2e-16 ***
## vinhos_rl$totalsulfurdioxide -2.832e-03 2.724e-04 -10.396 < 2e-16 ***
## vinhos_rl$density -9.163e+01 1.205e+01 -7.602 3.32e-14 ***
## vinhos_rl$pH 6.225e-01 8.973e-02 6.937 4.38e-12 ***
## vinhos_rl$sulphates 8.525e-01 7.590e-02 11.232 < 2e-16 ***
## vinhos_rl$alcohol 2.081e-01 1.608e-02 12.939 < 2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.7369 on 6484 degrees of freedom
## Multiple R-squared: 0.288, Adjusted R-squared: 0.2869
## F-statistic: 262.3 on 10 and 6484 DF, p-value: < 2.2e-16
Através da sumarização do modelo podemos observar que a quantidade de sal presente nos vinhos não é relevante para a estimarmos a qualidade e será removida da modelo final
Com o gráfico abaixo podemos concluir que os resíduos da predição com o modelo desenvolvido que a premissa de normalidade é atendida:
qqnorm(residuals(modelo_rl_final), ylab="Resíduos",xlab="Quantis teóricos",main="")
qqline(residuals(modelo_rl_final)) Concluímos que com o modelo de regressão desenvolvido temos um erro quadrático médio de aproximadamente 0,74.
## Warning in predict.lm(modelo_rl_final, interval = "prediction", level = 0.95): predictions on current data refer to _future_ responses
## [1] 0.7362984
Árvores de Regressão são idênticas às árvores de decisão porém para variáveis escalares, na figura abaixo está a plotagem de uma árvore de regressão de 9 níveis na qual as folhas agrupam os vinhos por sua qualidade, o split do algoritmo foi setado em 325 que é aproximadamente o valor de 5% da amostra. Com este este algorimo atingimos um erro quadrático médio de aproximadamente 0,71.
modelo_arvore <- rpart(quality ~ fixedacidity + volatileacidity + citricacid + residualsugar + chlorides + freesulfurdioxide + totalsulfurdioxide + density + pH + sulphates + alcohol, data=vinhos_rl,
cp = 0.001,minsplit = 325,maxdepth=20)
rpart.plot(modelo_arvore, type=4, extra=1, under=FALSE, clip.right.labs=TRUE,
fallen.leaves=FALSE, digits=2, varlen=-10, faclen=20,
cex=0.4, tweak=1.7,
compress=TRUE,
snip=FALSE)## Warning: labs do not fit even at cex 0.15, there may be some overplotting
## Warning: cex and tweak both specified, applying both
pred_arvore <- predict(modelo_arvore,interval = "prediction", level = 0.95)
mse_tree <- mean((vinhos_rl$quality - pred_arvore)^2)
sqrt(mse_tree)## [1] 0.7087093
Assim concluímos que entre os dois algoritmos apresentados o de melhor desempenho foi a Árvore de Regressão ainda que com uma diferença muito pequena entre eles.
Tendo em mente que os vinhos com nota superior igual à 6 sãos classificados com bons e os inferiores à isso são classificados como ruins podemos criar uma variável qualitativa e criarmos uma nova variável no dataset e trabalharmos sobre os dados que levam a esta classificação.
vinhos_class <- vinhos%>%
select(2:14)%>%
mutate(Qualidade = ifelse(quality >= 6, "BOM", "RUIM"))%>%
select(-quality)%>%
select(-Vinho)
vinhos_class$Qualidade <- factor(vinhos_class$Qualidade)
summary(vinhos_class)## fixedacidity volatileacidity citricacid residualsugar
## Min. : 3.800 Min. :0.0800 Min. :0.0000 Min. : 0.600
## 1st Qu.: 6.400 1st Qu.:0.2300 1st Qu.:0.2500 1st Qu.: 1.800
## Median : 7.000 Median :0.2900 Median :0.3100 Median : 3.000
## Mean : 7.215 Mean :0.3396 Mean :0.3186 Mean : 5.434
## 3rd Qu.: 7.700 3rd Qu.:0.4000 3rd Qu.:0.3900 3rd Qu.: 8.100
## Max. :15.900 Max. :1.5800 Max. :1.6600 Max. :31.600
## chlorides freesulfurdioxide totalsulfurdioxide density
## Min. :0.00900 Min. : 1.00 Min. : 6.0 Min. :0.9871
## 1st Qu.:0.03800 1st Qu.: 17.00 1st Qu.: 77.0 1st Qu.:0.9923
## Median :0.04700 Median : 29.00 Median :118.0 Median :0.9949
## Mean :0.05603 Mean : 30.49 Mean :115.7 Mean :0.9947
## 3rd Qu.:0.06500 3rd Qu.: 41.00 3rd Qu.:156.0 3rd Qu.:0.9970
## Max. :0.61100 Max. :146.50 Max. :366.5 Max. :1.0103
## pH sulphates alcohol Qualidade
## Min. :2.720 Min. :0.2200 Min. : 0.9567 BOM :4112
## 1st Qu.:3.110 1st Qu.:0.4300 1st Qu.: 9.5000 RUIM:2383
## Median :3.210 Median :0.5100 Median :10.3000
## Mean :3.218 Mean :0.5312 Mean :10.4860
## 3rd Qu.:3.320 3rd Qu.:0.6000 3rd Qu.:11.3000
## Max. :4.010 Max. :2.0000 Max. :14.9000
Plotamos alguns gráficos para entendermos a relação das variáveis com a qualidade atribuída aos vinhos:
#comando para gerar em 4 linhas e duas colunas os plots
par (mfrow=c(1,2))
plot(vinhos_class$Qualidade, vinhos_class$fixedacidity,ylab="fixedacidity",xlab="Qualidade",col=c('red','darkgreen'))
plot(vinhos_class$Qualidade, vinhos_class$volatilacidity,ylab="volatilacidity",xlab="Qualidade",col=c('red','darkgreen'))plot(vinhos_class$Qualidade, vinhos_class$citricacid,ylab="citricacid",xlab="Qualidade",col=c('red','darkgreen'))
plot(vinhos_class$Qualidade, vinhos_class$residualsugar,ylab="residualsugar",xlab="Qualidade",col=c('red','darkgreen'))plot(vinhos_class$Qualidade, vinhos_class$chlorides,ylab="chlorides",xlab="Qualidade",col=c('red','darkgreen'))
plot(vinhos_class$Qualidade, vinhos_class$freesulfordioxide,ylab="freesulfordioxide",xlab="Qualidade",col=c('red','darkgreen'))plot(vinhos_class$Qualidade, vinhos_class$totalsulfordioxide,ylab="totalsulfordioxide",xlab="Qualidade",col=c('red','darkgreen'))
plot(vinhos_class$Qualidade, vinhos_class$density,ylab="density",xlab="Qualidade",col=c('red','darkgreen'))plot(vinhos_class$Qualidade, vinhos_class$pH,ylab="pH",xlab="Qualidade",col=c('red','darkgreen'))
plot(vinhos_class$Qualidade, vinhos_class$sulphates,ylab="sulphates",xlab="Qualidade",col=c('red','darkgreen'))Alguns dos gráficos como freesulfordioxide e totalsulfordioxide não trazem boa compreensão sobre a relação das variáveis com a qualidade.
Para averiguarmos melhor usaremos o corrplot para enxergarmos as correlações.
matcor <- hetcor(vinhos_class)
panel.cor <- function(x, y, digits=2, prefix ="", cex.cor,
...) {
usr <- par("usr")
on.exit(par(usr))
par(usr = c(0, 1, 0, 1))
r <- cor(x, y , use = "pairwise.complete.obs")
txt <- format(c(r, 0.123456789), digits = digits) [1]
txt <- paste(prefix, txt, sep = "")
if (missing(cex.cor))
cex <- 0.8/strwidth(txt)
text(0.5, 0.5, txt, cex = cex * abs(r))
}
pairs(vinhos_class, lower.panel=panel.smooth, upper.panel=panel.cor) As variáveis que apresentam os maiores graus de correção com a qualidade (BOM ou RUIM) ainda que negativas são teor alcólico, densidade e acidez volátil.
A fim de categorizar os vinhos a partir de suas características utilizaremos as técnicas de regressão logística e árvore de decisão. Para o uso de tais técnicas dividiremos nosso dataset em 2/3 para o treinamento e 1/3 para a validação.
particao <- 2/3
set.seed(2019)
treino <- sample(1:NROW(vinhos_class), as.integer(particao*NROW(vinhos_class)))
trainData <- vinhos_class[treino,]
testData <- vinhos_class[-treino,]Com o intuito de selecionarmos as variáveis que utilizaremos na regressão logística primeiros iremos usar a árvore de decisão para identificarmos quais variáveis se apresentam como critérios de decisão.
modelo_arvore_decisao <- rpart (Qualidade ~ fixedacidity + volatileacidity + citricacid + residualsugar + chlorides + freesulfurdioxide + totalsulfurdioxide + density + pH + sulphates + alcohol, data=trainData, cp = 0.006,minsplit = 325,maxdepth=20)
rpart.plot(modelo_arvore_decisao, type=4, extra=104, under=FALSE, clip.right.labs=TRUE,
fallen.leaves=FALSE, digits=2, varlen=-3, faclen=20,
cex=0.4, tweak=1.7,
compress=TRUE,
snip=FALSE)## Warning: cex and tweak both specified, applying both
qualidade_predita <- predict(modelo_arvore_decisao ,testData , type = "class")
matriz.de.confusao<-table(testData$Qualidade, qualidade_predita)
matriz.de.confusao## qualidade_predita
## BOM RUIM
## BOM 1140 231
## RUIM 316 478
diagonal <- diag(matriz.de.confusao)
perc.erro <- 1 - sum(diagonal)/sum(matriz.de.confusao)
perc.erro## [1] 0.2526559
Observamos pela matriz de confusão a assertividade do modelo e seu percentual de erro de aproximadamente 25%.
Assim como na regressão linear a regressão logística se baseia em váriáveis independentes para chegar a uma variável dependente, porém neste caso, uma variável categórica
modelo_log<-glm(Qualidade ~ fixedacidity + volatileacidity + citricacid + residualsugar + chlorides + freesulfurdioxide + totalsulfurdioxide + density + pH + sulphates + alcohol,trainData, family=binomial(link=logit))
predito<-fitted(modelo_log)
hist(predito)fx_predito <- cut(predito, breaks=c(0,0.10,0.20,0.30,0.40,0.50,0.60,0.70,0.80,0.90,1), right=F)
plot(fx_predito , trainData$Qualidade)Predito_teste<-predict(modelo_log, testData)
fx_predito1 <- cut(Predito_teste, breaks=c(0,0.50,1), right=F)
MC <- table(testData$Qualidade, fx_predito1 , deparse.level = 2)
show(MC) ## fx_predito1
## testData$Qualidade [0,0.5) [0.5,1)
## BOM 105 63
## RUIM 157 138
## [1] 0.475162
Como podemos ver nos gráficos acima e também na matriz de confusão, o percentual de erro do modelo foi de aproximadamente 47%, o que nos leva a concluir que para a classificação dos vinhos entre BOM e RUIM o melhor método foi a Árvore de decisão.
Para análise dos grupos de vinhos a partir de sua características físico-químicas iremos utilizar três técnicas, são elas: Clusteres Hierárquicos, Componentes principais e K-means.
vinhos_clusters <- vinhos%>%select(2:12)
matcor <- cor(vinhos_clusters)
panel.cor <- function(x, y, digits=2, prefix ="", cex.cor,
...) {
usr <- par("usr")
on.exit(par(usr))
par(usr = c(0, 1, 0, 1))
r <- cor(x, y , use = "pairwise.complete.obs")
txt <- format(c(r, 0.123456789), digits = digits) [1]
txt <- paste(prefix, txt, sep = "")
if (missing(cex.cor))
cex <- 0.8/strwidth(txt)
text(0.5, 0.5, txt, cex = cex * abs(r))
}
pairs(vinhos_clusters, lower.panel=panel.smooth, upper.panel=panel.cor) Como já observado anteriormente, algumas das variáveis do dataset apresentam forte correlação entre si como freesulfordioxide e totalsulfordioxide, outro exemplo de forte correlação é alcohol e density.
Esta técnica consiste no desenvolvimento de componentes de análise que representem as características dos dados sem que que sofre interferência das variáveis que possuem forte correlação entre elas, possibilitando assim um melhor desempenho dos modelos.
vinhos_clusters_padr <- scale(vinhos_clusters)
pcacor_vinhos <- prcomp(vinhos_clusters_padr, scale = TRUE)
summary(pcacor_vinhos)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 1.7457 1.5796 1.2464 0.9833 0.84315 0.77705 0.72252
## Proportion of Variance 0.2771 0.2268 0.1412 0.0879 0.06463 0.05489 0.04746
## Cumulative Proportion 0.2771 0.5039 0.6451 0.7330 0.79763 0.85252 0.89998
## PC8 PC9 PC10 PC11
## Standard deviation 0.70529 0.58187 0.47916 0.18607
## Proportion of Variance 0.04522 0.03078 0.02087 0.00315
## Cumulative Proportion 0.94520 0.97598 0.99685 1.00000
## PC1 PC2 PC3 PC4
## fixedacidity 0.23910404 -0.33807511 0.43250569 -0.1709661
## volatileacidity 0.38097541 -0.11255471 -0.30693643 -0.2158823
## citricacid -0.15188291 -0.18391604 0.59195923 0.2670538
## residualsugar -0.34869935 -0.32675524 -0.16595686 -0.1541105
## chlorides 0.29082821 -0.31374730 -0.01715046 0.2393078
## freesulfurdioxide -0.43193476 -0.07720060 -0.13494093 0.3472041
## totalsulfurdioxide -0.48509509 -0.08972628 -0.10821419 0.2051820
## density 0.04914824 -0.58341217 -0.17637712 -0.0641519
## pH 0.21885812 0.16011307 -0.45145632 0.4231826
## sulphates 0.29435715 -0.18988071 0.07215266 0.6424321
## alcohol 0.09798390 0.46683382 0.26538696 0.1151572
## PC5 PC6 PC7 PC8
## fixedacidity 0.1664451 0.19792330 0.26625674 -0.394584106
## volatileacidity -0.1628338 0.47736368 0.41029176 0.049366008
## citricacid 0.1419215 -0.23493031 0.38953049 0.267785308
## residualsugar 0.3324208 0.25422224 -0.18773526 0.553079395
## chlorides -0.6289472 -0.16977181 0.06408220 0.454483200
## freesulfurdioxide -0.2256297 0.31998541 0.29813097 -0.231397403
## totalsulfurdioxide -0.1633365 0.13998358 0.14232190 -0.156133912
## density 0.3083237 -0.01282956 0.04655075 0.008632912
## pH 0.4556496 -0.29562139 0.41092850 0.030146350
## sulphates 0.1212510 0.31688435 -0.51970206 -0.151209674
## alcohol 0.1568179 0.52378264 0.13937689 0.394886518
## PC9 PC10 PC11
## fixedacidity 0.35393902 -0.275710686 0.342764960
## volatileacidity -0.49703756 0.151242411 0.079285372
## citricacid -0.41047402 0.232535464 -0.005864659
## residualsugar 0.08289593 0.002315094 0.444068724
## chlorides 0.29087307 -0.193036254 0.049905503
## freesulfurdioxide 0.37120968 0.484958597 0.002218858
## totalsulfurdioxide -0.31079449 -0.715539149 -0.057662504
## density 0.11545820 -0.009936672 -0.714906569
## pH 0.12700278 -0.137533920 0.209150183
## sulphates -0.20824498 0.045792937 0.076414301
## alcohol 0.24596120 -0.203656155 -0.335409887
pcacor_vinhos <- prcomp(vinhos_clusters_padr, scale = TRUE, retx = TRUE)
CP1 <- pcacor_vinhos$x[, 1]
CP2 <- pcacor_vinhos$x[, 2]
CP3 <- pcacor_vinhos$x[, 3]
CP4 <- pcacor_vinhos$x[, 4]
CP5 <- pcacor_vinhos$x[, 5]
CP6 <- pcacor_vinhos$x[, 6]
CP7 <- pcacor_vinhos$x[, 7]
CP8 <- pcacor_vinhos$x[, 8]
par (mfrow=c(1,2))
hist(CP1)
hist(CP2)Baseado no gráfico de Variãncia x Componente percebos que por volta de 8 componentes principais a variância diminui bastante, e interpretando os componentes percebos que cada um leva em conta com um peso maior seja positivo ou negativo cerca de 2 a 3 características físico-químicas dos vinhos. Adotaremos então os componentes de 1 a 8.
Assim como o próprio nome diz esta técnica demonstra a hierarquia entre os clusters dentro de um mesmo dataset
hier_cluster<-hclust(dist(vinhos_clusters_padr),method='ward.D2')
d <- dist(vinhos_clusters_padr, method = "euclidean")
plot(hier_cluster, ylab='distancia', cex=0.6)
groups <- cutree(hier_cluster, k=10)
rect.hclust(hier_cluster, k=10, border="red")
groups <- cutree(hier_cluster, k=7)
rect.hclust(hier_cluster, k=7, border="blue") Nos baseando nas características físico-químicas dos vinhos encontramos 10 clusters distintos, sendo alguns dele muito menores do que os demais e outros bem abrangentes, faz parte da avaliação compararmos os clusters encontrados com os componentes principais e procurarmos semelhanças. Reduzimos então o número de clusters para 7 (em azul) para que possamos obersvar a hierarquia.
hier_cluster_pca<-hclust(dist(pca_vinhos),method='ward.D2')
d <- dist(pca_vinhos, method = "euclidean")
plot(hier_cluster_pca, ylab='distancia', cex=0.6)
groups <- cutree(hier_cluster_pca, k=10)
rect.hclust(hier_cluster_pca, k=10, border="red")
groups <- cutree(hier_cluster_pca, k=7)
rect.hclust(hier_cluster_pca, k=7, border="blue") Existe uma diferença entre os clusters encontrados com os componentes principais e podemos inferir que esse diferença se se deve ao motivo dos componentes não sofrem com a alta correlação entre as variáveis. Podemos observar também que a diferença se repete mesmo quando diminuimos a quantidade de clusters, entretanto, quando usamos os componentes principais é perceptível a existência de apenas um grupo muito pequeno o que não ocorre quando nos baseamos nas variáveis explicativas do dataset.
É uma técnica não hierárquica que consiste na formação de clusters que agrupem observações a partir de um ponto central baseado na distância da observação ao ponto central, ao fim do k-means as observações estarão clusterizadas em torno do centróido ao qual tem a menor distância.
wss <- (nrow(vinhos_clusters_padr)-1)*sum(apply(vinhos_clusters_padr,2,var))
for (i in 2:100) wss[i] <- sum(kmeans(vinhos_clusters_padr,
centers=i, iter.max = 50)$withinss)
plot(1:100, wss, type="b", xlab="Número de clusters") Analisando o gráfico acima podemos verificar que com cerca 90 clusters teremos poucas diferenças entre observações que indiquem a existe de um novo cluster com características muito específicas.
set.seed(2019)
output_cluster<-kmeans(vinhos_clusters_padr,90, iter = 50)
cluster_vinho<-output_cluster$cluster
table (cluster_vinho)## cluster_vinho
## 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
## 99 108 62 162 83 57 31 97 117 150 20 109 18 36 74 108 129 56
## 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
## 28 75 43 64 32 49 63 48 63 124 105 70 94 96 52 41 45 90
## 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
## 40 61 98 38 24 80 66 77 85 85 16 68 6 54 91 123 68 46
## 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
## 98 111 77 96 101 20 66 57 20 56 62 30 147 67 83 70 20 95
## 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
## 90 81 71 35 35 95 113 104 53 101 88 73 29 106 27 93 118 83
clusplot(vinhos_clusters_padr, output_cluster$cluster, color=TRUE, shade=TRUE,
labels=2, lines=0 , cex=0.75)wss <- (nrow(pca_vinhos)-1)*sum(apply(pca_vinhos,2,var))
for (i in 2:100) wss[i] <- sum(kmeans(pca_vinhos,
centers=i, iter.max = 50)$withinss)
plot(1:100, wss, type="b", xlab="Número de clusters") Podemos observar que executando o k-means com os componentes principais encontramos cerca 80 clusters com tamanhos diferentes dos encontrados anteriormente como podemos ver abaixo.
set.seed(2019)
output_cluster_pca<-kmeans(pca_vinhos,80, iter = 50)
cluster_vinho_pca<-output_cluster_pca$cluster
table (cluster_vinho_pca)## cluster_vinho_pca
## 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
## 127 106 83 195 107 65 56 77 116 171 20 112 21 59 31 88 137 70
## 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
## 31 109 55 66 37 56 78 45 60 97 90 96 97 40 57 46 28 71
## 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
## 45 103 98 81 23 50 135 111 93 59 14 69 5 73 141 131 100 71
## 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
## 173 97 75 104 94 14 84 55 28 70 86 77 151 81 95 152 72 108
## 73 74 75 76 77 78 79 80
## 107 87 64 32 35 152 147 53
Concluímos que utilizando os componentes principais teremos um número menor de clusters porém com características que possibilitam uma melhor visualização desses agrupamentos.